home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / sorts / sorts.bas < prev    next >
BASIC Source File  |  1995-09-06  |  5KB  |  134 lines
  1.  
  2. '   SORTS.BAS
  3.  
  4. '   ***************************************************
  5. '   *   Don't forget SORTS.TXT in the global module   *
  6. '   ***************************************************
  7.  
  8. '   Being an example of an efficient in-memory sort routine.
  9. '   Contributed by Tom Dacon, for free.
  10.  
  11. '   This algorithm implements a refinement on the bubble sort which is
  12. '   referred to as a comb sort.  The comb sort has performance
  13. '   characteristics which make it nearly as fast as QuickSort with
  14. '   only minor modifications to the basic bubble sort algorithm.
  15.  
  16. '   Ref:  Byte Magazine, April 1991, "A Fast, Easy Sort",
  17. '         Stephen Lacey and Richard Box
  18.  
  19. '   The thing that's so cool about this algorithm is that it's relatively
  20. '   error-free to clone the routine for different types of data elements.
  21.  
  22. '   This implementation gets even faster for string sorting if you
  23. '   can use fixed-length strings and use the Mid$() function for
  24. '   swapping the contents.
  25.  
  26.  
  27. '   Depends on the following manifest constants
  28. '   being present in the global module.
  29. '
  30. '   Global Const FALSE, TRUE
  31. '   Global Const SORTASCENDING                 'sort-order argument
  32. '   Global Const SORTDESCENDING                'sort-order argument
  33. '   Global Const SORTIGNORECASE                'modifier for string sorts
  34.  
  35.     DefInt A-Z
  36.  
  37. Function SortAndOut (ByVal value1 As Integer, ByVal value2 As Integer) As Integer
  38. '
  39. '   And's out from the bits in <value1> whatever bits are set in <value2>
  40. '   and returns the result.
  41. '   For example, AndOut(&HFFFF, &H00FF) returns &HFF00.
  42. '
  43.    SortAndOut = (value1 And (&HFFFF Xor value2))
  44.  
  45. End Function
  46.  
  47. Sub SortStrings (array() As String, ByVal firstIndex As Integer, ByVal lastIndex As Integer, ByVal sortKey As Integer)
  48. '
  49. '     Sort an array, or subset of an array,
  50. '     according to specified sort key.
  51. '
  52. '   Input:
  53. '           array()    - array of elements to be sorted
  54. '           firstIndex - index in array() of 1st element to be sorted
  55. '           lastIndex  - index in array() of last element to be sorted
  56. '           sortkey    - one of SORTASCENDING or SORTDESCENDING
  57. '                        optionally combined with SORTIGNORECASE
  58. '                        as in (SORTASCENDING + SORTIGNORECASE)
  59. '                        or    (SORTASCENDING Or SORTIGNORECASE)
  60. '
  61.  
  62.     Const SHRINKFACTOR = 1.3        'magic number (see article)
  63.  
  64.     Dim gap        As Integer
  65.     Dim i          As Integer
  66.     Dim ignoreCase As Integer
  67.     Dim j          As Integer
  68.     Dim nElements  As Integer
  69.     Dim order      As Integer
  70.     Dim swapThem   As Integer   'Boolean(elements not in correct order)
  71.     Dim switches   As Integer   'Boolean(any swap occurred)
  72.     Dim top        As Integer
  73.  
  74.     Dim temp       As String    'for the swap
  75.  
  76.     nElements = lastIndex - firstIndex + 1  'form count of elements to sort
  77.  
  78.     If nElements > 1 Then   'if there's anything to sort...
  79.  
  80.         ignoreCase = ((sortKey And SORTIGNORECASE) <> 0)
  81.         order = SortAndOut(sortKey, SORTIGNORECASE)
  82.  
  83.         If (order = SORTASCENDING Or order = SORTDESCENDING) Then
  84.  
  85.             gap = nElements
  86.             Do
  87.                 gap = Int(gap / SHRINKFACTOR)
  88.                 Select Case gap
  89.                 Case 0
  90.                     gap = 1
  91.                 Case 9, 10
  92.                     gap = 11
  93.                 Case Else
  94.                 End Select
  95.  
  96.                 switches = False
  97.                 top = lastIndex - gap
  98.                 For i = firstIndex To top
  99.                     j = i + gap
  100.  
  101.                     Select Case order
  102.                     Case SORTASCENDING
  103.                         If ignoreCase Then
  104.                             swapThem = (UCase$(array(i)) > UCase$(array(j)))
  105.                         Else
  106.                             swapThem = (array(i) > array(j))
  107.                         End If
  108.                     Case SORTDESCENDING
  109.                         If ignoreCase Then
  110.                             swapThem = (UCase$(array(i)) < UCase$(array(j)))
  111.                         Else
  112.                             swapThem = (array(i) < array(j))
  113.                         End If
  114.                     End Select
  115.  
  116.                     '   If they're out of order, swap them.
  117.  
  118.                     If swapThem Then
  119.                         temp = array(i)
  120.                         array(i) = array(j)
  121.                         array(j) = temp
  122.                         switches = True 'indicate we weren't done
  123.                     End If
  124.  
  125.                 Next i
  126.  
  127.            Loop While switches Or (gap > 1)
  128.  
  129.         End If  'a valid sort order was supplied
  130.     End If  'we have anything to sort
  131.  
  132. End Sub
  133.  
  134.